home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / xerprn.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.4 KB  |  178 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let* ((newlin "$$"))
  12.   (declare (type (simple-array base-char (2)) newlin))
  13.   (defun xerprn (prefix npref messg nwrap)
  14.     (declare (type f2cl-lib:integer4 nwrap npref)
  15.              (type (simple-array base-char (*)) messg prefix))
  16.     (prog ((iu (make-array 5 :element-type 'f2cl-lib:integer4)) (nunit 0)
  17.            (cbuff
  18.             (make-array '(148)
  19.                         :element-type
  20.                         'base-char
  21.                         :initial-element
  22.                         #\Space))
  23.            (idelta 0) (lpiece 0) (nextc 0) (lenmsg 0) (lwrap 0) (lpref 0) (i 0)
  24.            (n 0))
  25.       (declare (type (simple-array f2cl-lib:integer4 (5)) iu)
  26.                (type f2cl-lib:integer4 n i lpref lwrap lenmsg nextc lpiece
  27.                 idelta nunit)
  28.                (type (simple-array base-char (148)) cbuff))
  29.       (multiple-value-bind
  30.           (var-0 var-1)
  31.           (xgetua iu nunit)
  32.         (declare (ignore var-0))
  33.         (setf nunit var-1))
  34.       (setf n (f2cl-lib:i1mach 4))
  35.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  36.                     ((> i nunit) nil)
  37.         (tagbody
  38.           (if (= (f2cl-lib:fref iu (i) ((1 5))) 0)
  39.               (f2cl-lib:fset (f2cl-lib:fref iu (i) ((1 5))) n))
  40.          label10))
  41.       (cond ((< npref 0) (setf lpref (f2cl-lib:len prefix)))
  42.             (t (setf lpref npref)))
  43.       (setf lpref
  44.               (min (the f2cl-lib:integer4 16) (the f2cl-lib:integer4 lpref)))
  45.       (if (/= lpref 0)
  46.           (f2cl-lib:fset-string (f2cl-lib:fref-string cbuff (1 lpref)) prefix))
  47.       (setf lwrap
  48.               (max (the f2cl-lib:integer4 16)
  49.                    (the f2cl-lib:integer4
  50.                         (min (the f2cl-lib:integer4 132)
  51.                              (the f2cl-lib:integer4 nwrap)))))
  52.       (setf lenmsg (f2cl-lib:len messg))
  53.       (setf n lenmsg)
  54.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  55.                     ((> i n) nil)
  56.         (tagbody
  57.           (if
  58.            (f2cl-lib:fstring-/= (f2cl-lib:fref-string messg (lenmsg lenmsg))
  59.                                 " ")
  60.            (go label30))
  61.           (setf lenmsg (f2cl-lib:int-sub lenmsg 1))
  62.          label20))
  63.      label30
  64.       (cond
  65.        ((= lenmsg 0)
  66.         (f2cl-lib:fset-string
  67.          (f2cl-lib:fref-string cbuff ((+ lpref 1) (f2cl-lib:int-add lpref 1)))
  68.          " ")
  69.         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  70.                       ((> i nunit) nil)
  71.           (tagbody
  72.             (f2cl-lib:fformat (f2cl-lib:fref iu (i) ((1 5)))
  73.                               (("~A~%"))
  74.                               (f2cl-lib:fref-string cbuff
  75.                                                     (1
  76.                                                      (f2cl-lib:int-add lpref
  77.                                                                        1))))
  78.            label40))
  79.         (go end_label)))
  80.       (setf nextc 1)
  81.      label50
  82.       (setf lpiece
  83.               (f2cl-lib:index (f2cl-lib:fref-string messg (nextc lenmsg))
  84.                               newlin))
  85.       (cond
  86.        ((= lpiece 0)
  87.         (tagbody
  88.           (setf idelta 0)
  89.           (setf lpiece
  90.                   (min (the f2cl-lib:integer4 lwrap)
  91.                        (the f2cl-lib:integer4
  92.                             (f2cl-lib:int-sub (f2cl-lib:int-add lenmsg 1)
  93.                                               nextc))))
  94.           (cond
  95.            ((< lpiece (f2cl-lib:int-add lenmsg 1 (f2cl-lib:int-sub nextc)))
  96.             (f2cl-lib:fdo (i (f2cl-lib:int-add lpiece 1)
  97.                            (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
  98.                           ((> i 2) nil)
  99.               (tagbody
  100.                 (cond
  101.                  ((f2cl-lib:fstring-=
  102.                    (f2cl-lib:fref-string messg
  103.                                          ((+ nextc i (f2cl-lib:int-sub 1))
  104.                                           (f2cl-lib:int-add nextc
  105.                                                             i
  106.                                                             (f2cl-lib:int-sub
  107.                                                              1))))
  108.                    " ")
  109.                   (setf lpiece (f2cl-lib:int-sub i 1)) (setf idelta 1)
  110.                   (go label54)))
  111.                label52))))
  112.          label54
  113.           (f2cl-lib:fset-string
  114.            (f2cl-lib:fref-string cbuff
  115.                                  ((+ lpref 1) (f2cl-lib:int-add lpref lpiece)))
  116.            (f2cl-lib:fref-string messg
  117.                                  (nextc
  118.                                   (f2cl-lib:int-sub
  119.                                    (f2cl-lib:int-add nextc lpiece)
  120.                                    1))))
  121.           (setf nextc (f2cl-lib:int-add nextc lpiece idelta))))
  122.        ((= lpiece 1) (setf nextc (f2cl-lib:int-add nextc 2)) (go label50))
  123.        ((> lpiece (f2cl-lib:int-add lwrap 1))
  124.         (tagbody
  125.           (setf idelta 0)
  126.           (setf lpiece lwrap)
  127.           (f2cl-lib:fdo (i (f2cl-lib:int-add lpiece 1)
  128.                          (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
  129.                         ((> i 2) nil)
  130.             (tagbody
  131.               (cond
  132.                ((f2cl-lib:fstring-=
  133.                  (f2cl-lib:fref-string messg
  134.                                        ((+ nextc i (f2cl-lib:int-sub 1))
  135.                                         (f2cl-lib:int-add nextc
  136.                                                           i
  137.                                                           (f2cl-lib:int-sub
  138.                                                            1))))
  139.                  " ")
  140.                 (setf lpiece (f2cl-lib:int-sub i 1)) (setf idelta 1)
  141.                 (go label58)))
  142.              label56))
  143.          label58
  144.           (f2cl-lib:fset-string
  145.            (f2cl-lib:fref-string cbuff
  146.                                  ((+ lpref 1) (f2cl-lib:int-add lpref lpiece)))
  147.            (f2cl-lib:fref-string messg
  148.                                  (nextc
  149.                                   (f2cl-lib:int-sub
  150.                                    (f2cl-lib:int-add nextc lpiece)
  151.                                    1))))
  152.           (setf nextc (f2cl-lib:int-add nextc lpiece idelta))))
  153.        (t (setf lpiece (f2cl-lib:int-sub lpiece 1))
  154.         (f2cl-lib:fset-string
  155.          (f2cl-lib:fref-string cbuff
  156.                                ((+ lpref 1) (f2cl-lib:int-add lpref lpiece)))
  157.          (f2cl-lib:fref-string messg
  158.                                (nextc
  159.                                 (f2cl-lib:int-sub
  160.                                  (f2cl-lib:int-add nextc lpiece)
  161.                                  1))))
  162.         (setf nextc (f2cl-lib:int-add nextc lpiece 2))))
  163.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  164.                     ((> i nunit) nil)
  165.         (tagbody
  166.           (f2cl-lib:fformat (f2cl-lib:fref iu (i) ((1 5)))
  167.                             (("~A~%"))
  168.                             (f2cl-lib:fref-string cbuff
  169.                                                   (1
  170.                                                    (f2cl-lib:int-add lpref
  171.                                                                      lpiece))))
  172.          label60))
  173.       (if (<= nextc lenmsg) (go label50))
  174.       (go end_label)
  175.      end_label
  176.       (return (values nil nil nil nil)))))
  177.  
  178.